/* Definitions for builtin functions.

   This file is part of khipu.

   khipu is free software: you can redistribute it and/or modify
   it under the terms of the GNU Lesser General Public License as published by
   the Free Software Foundation; either version 3 of the License, or
   (at your option) any later version.

   This program is distributed in the hope that it will be useful,
   but WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   GNU Lesser General Public License for more details.

   You should have received a copy of the GNU Lesser General Public License
   along with this program.  If not, see <https://www.gnu.org/licenses/>.  */

#include <cstdio>
#include <new>
#include "khipu.hpp"
#include "utils/lazy.hpp"

KP_DECLS_BEGIN

[[noreturn]] static void
invalid_arg (interpreter *interp, const char *name)
{
  char buf[128];
  sprintf (buf, "invalid argument(s) passed to '%s'", name);
  interp->raise ("arg-error", buf);
}

static int
write_generic (interpreter *interp, stream *strm,
  object obj, io_info& info)
{
  char buf[64];
  return (strm->write (interp, "#<", 2) +
    write_S (interp, strm, type_name (type (obj)), info) +
    strm->write (interp, " object at ", 11) +
    strm->write (interp, buf, sprintf (buf, "%p", unmask (obj))) +
    strm->putb (interp, '>'));
}

#define INTERN(name)   \
  intern (interp, name, sizeof (name) - 1, as_package (root_package))

#define INTERN_N(name)   \
  intern (interp, name, as_package (root_package))

static object
call_binary (interpreter *interp, object x, object y,
  object (*fn) (interpreter *, object , object), const char *method)
{
  if (kp_likely (fn (interp, x, y) != UNBOUND))
    return (interp->retval);

  interp->push (symval (INTERN_N (method)));
  interp->push (x);
  interp->push (y);

  if (method_call (interp, 2))
    return (interp->retval);

  {
    valref_head h (interp);
    fast_valref sub_x (interp, builtin_member (x)),
                sub_y (interp, builtin_member (y));

    if (*sub_x != UNBOUND && *sub_y != UNBOUND &&
        fn (interp, *sub_x, *sub_y) != UNBOUND)
      return (interp->retval);
  }

  interp->raise ("type-error",
    KP_SPRINTF (interp, "invalid types: got %Q and %Q",
                type (x), type (y)));
  return (0);   // NOTREACHED.
}

static int
write_any (interpreter *interp, stream *strm,
  object obj, io_info& info)
{
  interp->push (symval (INTERN ("g-write")));
  interp->push (obj);
  interp->push (strm->as_obj ());

  if (method_call (interp, 2))
    return (0);

  object tname = type_name (obj);
  if (tname == NIL)
    return (write_generic (interp, strm, obj, info));

  return (strm->write (interp, "#<type ", 7) +
          xwrite (interp, strm, tname, info) +
          strm->putb (interp, '>'));
}

int xwrite (interpreter *interp, stream *strm,
  object obj, io_info& info)
{
  int ret = -2, itp = itype (obj);

  switch (itp)
    {
#define DISPATCH(type, suffix)   \
  case typecode::type:   \
    ret = write_##suffix (interp, strm, obj, info);   \
    break

      DISPATCH (INT, i);
      DISPATCH (CHAR, c);
      DISPATCH (CONS, L);
      DISPATCH (BIGINT, I);
      DISPATCH (FLOAT, f);
      DISPATCH (BIGFLOAT, F);
      DISPATCH (BVECTOR, b);
      DISPATCH (STR, s);
      DISPATCH (ARRAY, a);
      DISPATCH (TABLE, u);
      DISPATCH (TUPLE, o);
      DISPATCH (SYMBOL, S);
      DISPATCH (FCT, x);
      DISPATCH (PKG, P);

      default:
        if (obj == UNBOUND)
          ret = strm->write (interp, "#<unbound>", 10);
        else if (itp == typecode::CORO || itp == typecode::STREAM ||
            (info.flags & io_info::FLG_SAFE))
          ret = write_generic (interp, strm, obj, info);
        else
          ret = write_any (interp, strm, obj, info);

#undef DISPATCH
    }

  return (strm->err_p () ? -1 : ret);
}

static inline bool
ref_obj_p (object obj, int tp)
{
  switch (tp)
    {
      case typecode::INT:
      case typecode::CHAR:
        return (false);
      case typecode::PKG:
        return (obj != root_package && obj != kword_package);
      case typecode::FCT:
        return (!as_varobj(obj)->flagged_p (function::artificial_flag));
      default:
        return (true);
    }
}

int64_t xpack (interpreter *interp, stream *strm,
  object obj, pack_info& info)
{
  int64_t ret = 0;
  int tp = itype (obj);

  if (nil_p (obj))
    return (strm->putb (interp, PACK_NIL));
  else if (array_p (obj) && len_a (obj) == 0)
    return (strm->putb (interp, PACK_EMPTY_ARRAY));
  else if ((str_p (obj) || bvector_p (obj)) && as_bvector(obj)->nbytes == 0)
    return (strm->putb (interp, str_p (obj) ?
      PACK_EMPTY_STR : PACK_EMPTY_BVECTOR));
  else if (tp == typecode::CHAR && as_char (obj) <= 0xff)
    {
      unsigned char data[] = { PACK_CHAR8, (unsigned char)as_char (obj) };
      return (strm->write (interp, data, sizeof (data)));
    }
  else if (tp == typecode::INT && as_int (obj) <= 0x7f && as_int (obj) >= -128)
    {
      unsigned char data[] = { PACK_INT8, (unsigned char)as_int (obj) };
      return (strm->write (interp, data, sizeof (data)));
    }
  else if (tp == typecode::INSTANCE && builtin_typespec_p (obj))
    {
      unsigned char data[] = { PACK_TYPESPEC,
        (unsigned char)as_instance(obj)->type_code () };
      return (strm->write (interp, data, sizeof (data)));
    }

  {
    object off = info.get (interp, obj);
    if (off != UNBOUND)
      {
        int ioff = as_int (off);
        info.touch (interp, ioff);
        return (strm->putb (interp, PACK_REF_INT32) +
                strm->write (interp, &ioff));
      }
  }

  if (ref_obj_p (obj, tp))
    info.add_mapping (interp, obj, strm->tell (interp));

  ret += strm->putb (interp, tp);

  switch (tp)
    {
#define DISPATCH(type, suffix)   \
  case typecode::type:   \
    ret += pack_##suffix (interp, strm, obj, info);   \
    break

      DISPATCH (INT, i);
      DISPATCH (CHAR, c);
      DISPATCH (CONS, L);
      DISPATCH (BIGINT, I);
      DISPATCH (FLOAT, f);
      DISPATCH (BIGFLOAT, F);
      DISPATCH (BVECTOR, b);
      DISPATCH (STR, s);
      DISPATCH (ARRAY, a);
      DISPATCH (TABLE, u);
      DISPATCH (TUPLE, o);
      DISPATCH (SYMBOL, S);
      DISPATCH (FCT, x);
      DISPATCH (CORO, G);
      DISPATCH (PKG, P);
      DISPATCH (INSTANCE, w);
      default:
        // XXX: Other objects.
        invalid_arg (interp, "pack");
#undef DISPATCH
    }

  return (strm->err_p () ? -1 : ret);
}

object xunpack (interpreter *interp, stream *strm, pack_info& info)
{
  object ret = UNBOUND;
  *info.offset = copy (interp, strm->tell (interp));
  int tp = strm->getb (interp);

  if (tp < 0)
    kp_return (info.error ("failed to read typecode"));

  bool save = (tp & 0x80) != 0;
  tp &= ~0x80;

  switch (tp)
    {
      case PACK_NIL:
        kp_return (NIL);
      case PACK_EMPTY_ARRAY:
        kp_return (alloc_array (interp, 0));
      case PACK_EMPTY_BVECTOR:
        kp_return (alloc_bvector (interp, 0));
      case PACK_EMPTY_STR:
        kp_return (alloc_str (interp, 0));

      case PACK_INT8:
      case PACK_CHAR8:
        {
          int b = strm->getb (interp);
          kp_return (b < 0 ? info.error ("failed to read byte") :
            (tp == PACK_INT8 ? fixint ((int8_t)b) : charobj ((uint8_t)b)));
        }

      case PACK_REF_INT32:
        {
          int off;
          if (!strm->sread (interp, &off))
            kp_return (info.error ("failed to read integer"));

          interp->retval = info.get (interp, intobj (interp, off));
          if (interp->retval == UNBOUND)
            info.error ("invalid back reference to object");

          return (interp->retval);
        }

      case PACK_REF_OBJ:
        kp_return (info.get (interp, xunpack (interp, strm, info)));

      case PACK_TYPESPEC:
        if ((tp = strm->getb (interp)) < 0)
          kp_return (info.error ("failed to read typespec code"));

        interp->retval = builtin_type (tp);
        if (interp->retval == UNBOUND)
          interp->retval = info.error ("invalid typespec");

        return (interp->retval);
    
#define DISPATCH(type, suffix)   \
  case typecode::type:   \
    ret = unpack_##suffix (interp, strm, info, save);   \
    break

      DISPATCH (INT, i);
      DISPATCH (CHAR, c);
      DISPATCH (CONS, L);
      DISPATCH (BIGINT, I);
      DISPATCH (FLOAT, f);
      DISPATCH (BIGFLOAT, F);
      DISPATCH (BVECTOR, b);
      DISPATCH (STR, s);
      DISPATCH (ARRAY, a);
      DISPATCH (TABLE, u);
      DISPATCH (TUPLE, o);
      DISPATCH (SYMBOL, S);
      DISPATCH (FCT, x);
      DISPATCH (CORO, G);
      DISPATCH (PKG, P);
      DISPATCH (INSTANCE, w);
      default:
        // XXX: Other objects.
        invalid_arg (interp, "unpack");
#undef DISPATCH
    }

  kp_return (ret);
}

object copy (interpreter *interp, object obj, bool deep)
{
  if (immediate_p (obj) || (varobj_p (obj) &&
      (as_varobj(obj)->flagged_p (FLAGS_CONST))))
    kp_return (obj);

  switch (itype (obj))
    {
#define DISPATCH(type, suffix)   \
  case typecode::type:   \
    return (copy_##suffix (interp, obj, deep))

      DISPATCH (CONS, L);
      DISPATCH (BVECTOR, b);
      DISPATCH (ARRAY, a);
      DISPATCH (TABLE, u);
      DISPATCH (TUPLE, o);
      DISPATCH (SYMBOL, S);
      default:
        invalid_arg (interp, "copy");
#undef DISPATCH
    }
}

static inline uint32_t
raw_hash (object obj)
{
#ifndef KP_ARCH_WIDE
  return ((uint32_t)obj >> 3);
#else
  return (mix_hash (obj >> 32, obj & 0xffffffff));
#endif
}

static uint32_t
hash_helper (interpreter *interp, object obj, bool& got)
{
  got = true;
  switch (itype (obj))
    {
#define DISPATCH(type, suffix)   \
  case typecode::type:   \
    return (hash_##suffix (interp, obj))

#define hash_w(ip, x)   got = false

      DISPATCH (CONS, L);
      DISPATCH (BIGINT, I);
      DISPATCH (FLOAT, f);
      DISPATCH (BIGFLOAT, F);
      DISPATCH (BVECTOR, b);
      DISPATCH (STR, s);
      DISPATCH (ARRAY, a);
      DISPATCH (TABLE, u);
      DISPATCH (TUPLE, o);
      DISPATCH (SYMBOL, S);
      DISPATCH (PKG, P);
      DISPATCH (INSTANCE, w);
#undef DISPATCH
#undef hash_w
      default:
        return (raw_hash (obj));
    }
}

uint32_t xhash (interpreter *interp, object obj)
{
  bool got;
  uint32_t ret = hash_helper (interp, obj, got);

  if (kp_likely (got))
    return (ret);

  interp->push (symval (INTERN ("g-hash")));
  interp->push (obj);

  if (method_call (interp, 1))
    {
      int iv;

      if (as<int> (interp->retval, iv))
        return (iv);
      else if (bigint *lp = as<bigint> (interp->retval))
        return (hash_I (interp, lp->as_obj ()));

      interp->raise ("type-error", "hash function must return an integer");
    }

  {
    valref sub_obj (interp, builtin_member (obj));
    if (*sub_obj != UNBOUND)
      return (hash_helper (interp, *sub_obj, got));
  }

  return (ret);
}

object length (interpreter *interp, object obj)
{
  switch (itype (obj))
    {
      case typecode::ARRAY:
        return (fixint (len_a (obj)));
      case typecode::TUPLE:
        return (fixint (len_o (obj)));
      case typecode::BVECTOR:
        return (fixint (len_b (obj)));
      case typecode::STR:
        return (fixint (len_s (obj)));
      case typecode::TABLE:
        return (fixint (len_u (obj)));
      case typecode::CONS:
        return (fixint (len_L (interp, obj)));
      default:
        {
          interp->push (symval (INTERN ("g-len")));
          interp->push (obj);

          if (!method_call (interp, 1))
            interp->raise ("dispatch-error", "no applicable method "
                                             "found for g-len");

          int out;
          if (as<int> (interp->retval, out) || as<bigint> (interp->retval))
            return (interp->retval);

          interp->raise ("type-error", "len must return an integer");
          return (fixint (0));   // NOTREACHED.
        }
    }
}

// Binary operations.

#define MIX(t1, t2)   ((t1) + ((t2) * typecode::LAST))

static object
add_helper (interpreter *interp, object x, object y)
{
  switch (MIX (itype (x), itype (y)))
    {
#define DISPATCH_1(type, suffix)   \
  case MIX (typecode::type, typecode::type):   \
    return (add_##suffix##suffix (interp, x, y))

#define DISPATCH_2(t1, t2, s1, s2)   \
  case MIX (typecode::t1, typecode::t2):   \
    return (add_##s1##s2 (interp, x, y));   \
  case MIX (typecode::t2, typecode::t1):   \
    return (add_##s1##s2 (interp, y, x))

      DISPATCH_1 (INT, i);
      DISPATCH_2 (INT, BIGINT, i, I);
      DISPATCH_2 (INT, FLOAT, i, f);
      DISPATCH_2 (INT, BIGFLOAT, i, F);

      DISPATCH_1 (BIGINT, I);
      DISPATCH_2 (BIGINT, FLOAT, I, f);
      DISPATCH_2 (BIGINT, BIGFLOAT, I, F);

      DISPATCH_1 (FLOAT, f);
      DISPATCH_2 (FLOAT, BIGFLOAT, f, F);
      
      DISPATCH_1 (BIGFLOAT, F);

      DISPATCH_1 (CHAR, c);

      DISPATCH_1 (STR, s);

      // Need to handle this case manually, since addition is not commutative.
      case MIX (typecode::STR, typecode::CHAR):
        return (add_sc (interp, x, y));
      case MIX (typecode::CHAR, typecode::STR):
        return (add_cs (interp, x, y));

      DISPATCH_1 (BVECTOR, b);

      DISPATCH_1 (ARRAY, a);

      DISPATCH_1 (CONS, L);

      default:
        return (UNBOUND);

#undef DISPATCH_1
#undef DISPATCH_2
    }
}

object add (interpreter *interp, object x, object y)
{
  return (call_binary (interp, x, y, add_helper, "g-add"));
}

#ifndef KP_ARCH_WIDE

template <class T>
static inline void inplace_neg (T& val)
{
  val = -val;
}

#endif

static object
sub_helper (interpreter *interp, object x, object y)
{
  switch (MIX (itype (x), itype (y)))
    {
#define DISPATCH_1(type, suffix)   \
  case MIX (typecode::type, typecode::type):   \
    return (sub_##suffix##suffix (interp, x, y))

#define DISPATCH_2(t1, t2, s1, s2)   \
  case MIX (typecode::t1, typecode::t2):   \
    return (sub_##s1##s2 (interp, x, y));   \
  case MIX (typecode::t2, typecode::t1):   \
    (void)sub_##s1##s2 (interp, y, x);   \
    break

      DISPATCH_1 (INT, i);
      DISPATCH_2 (INT, BIGINT, i, I);
      DISPATCH_2 (INT, FLOAT, i, f);
      DISPATCH_2 (INT, BIGFLOAT, i, F);

      DISPATCH_1 (BIGINT, I);
      DISPATCH_2 (BIGINT, FLOAT, I, f);
      DISPATCH_2 (BIGINT, BIGFLOAT, I, F);

      DISPATCH_1 (FLOAT, f);
      DISPATCH_2 (FLOAT, BIGFLOAT, f, F);

      DISPATCH_1 (BIGFLOAT, F);

      default:
        return (UNBOUND);
    }

#undef DISPATCH_1
#undef DISPATCH_2

  /* Instead of doing (x - y), we performed (y - x), so we now have to
   * negate the result. We can do this in-place, since the return value
   * can only be seen by us. */

  if (fixint_p (interp->retval))
    (void)neg_i (interp, interp->retval);
  else if (varobj_p (interp->retval))
#ifdef KP_ARCH_WIDE
    interp->retval ^= SIGN_BIT;
#else
    switch (itype (interp->retval))
      {
        case typecode::BIGINT:
          inplace_neg (as_bigint(interp->retval)->len);
          break;
        case typecode::FLOAT:
          inplace_neg (as_fltobj(interp->retval)->val);
          break;
        case typecode::BIGFLOAT:
          inplace_neg (as_bigfloat(interp->retval)->len);
          break;
      }
#endif

  return (interp->retval);
}

object sub (interpreter *interp, object x, object y)
{
  return (call_binary (interp, x, y, sub_helper, "g-sub"));
}

static object
mul_helper (interpreter *interp, object x, object y)
{
  switch (MIX (itype (x), itype (y)))
    {
#define DISPATCH_1(type, suffix)   \
  case MIX (typecode::type, typecode::type):   \
    return (mul_##suffix##suffix (interp, x, y))

#define DISPATCH_2(t1, t2, s1, s2)   \
  case MIX (typecode::t1, typecode::t2):   \
    return (mul_##s1##s2 (interp, x, y));   \
  case MIX (typecode::t2, typecode::t1):   \
    return (mul_##s1##s2 (interp, y, x))

      DISPATCH_1 (INT, i);
      DISPATCH_2 (INT, BIGINT, i, I);
      DISPATCH_2 (INT, FLOAT, i, f);
      DISPATCH_2 (INT, BIGFLOAT, i, F);
      DISPATCH_2 (INT, CHAR, i, c);
      DISPATCH_2 (INT, ARRAY, i, a);
      DISPATCH_2 (INT, BVECTOR, i, b);
      DISPATCH_2 (INT, STR, i, s);

      DISPATCH_1 (BIGINT, I);
      DISPATCH_2 (BIGINT, FLOAT, I, f);
      DISPATCH_2 (BIGINT, BIGFLOAT, I, F);

      DISPATCH_1 (FLOAT, f);
      DISPATCH_2 (FLOAT, BIGFLOAT, f, F);

      DISPATCH_1 (BIGFLOAT, F);

     default:
       return (UNBOUND);
    }

#undef DISPATCH_1
#undef DISPATCH_2
}

object mul (interpreter *interp, object x, object y)
{
  return (call_binary (interp, x, y, mul_helper, "g-mul"));
}

static object
div_helper (interpreter *interp, object x, object y)
{
  switch (MIX (itype (x), itype (y)))
    {
#define DISPATCH_1(type, suffix)   \
  case MIX (typecode::type, typecode::type):   \
    return (div_##suffix##suffix (interp, x, y))

#define DISPATCH_2(t1, t2, s1, s2)   \
  case MIX (typecode::t1, typecode::t2):   \
    return (div_##s1##s2 (interp, x, y));   \
  case MIX (typecode::t2, typecode::t1):   \
    return (div_##s2##s1 (interp, x, y))

      DISPATCH_1 (INT, i);
      DISPATCH_2 (INT, BIGINT, i, I);
      DISPATCH_2 (INT, FLOAT, i, f);
      DISPATCH_2 (INT, BIGFLOAT, i, F);

      DISPATCH_1 (BIGINT, I);
      DISPATCH_2 (BIGINT, FLOAT, I, f);
      DISPATCH_2 (BIGINT, BIGFLOAT, I, F);

      DISPATCH_1 (FLOAT, f);
      DISPATCH_2 (FLOAT, BIGFLOAT, f, F);

      DISPATCH_1 (BIGFLOAT, F);

      default:
        return (UNBOUND);
    }

#undef DISPATCH_1
#undef DISPATCH_2
}

object div (interpreter *interp, object x, object y)
{
  return (call_binary (interp, x, y, div_helper, "g-div"));
}

object modulo (interpreter *interp, object x, object y)
{
  switch (MIX (itype (x), itype (y)))
    {
#define DISPATCH_1(type, suffix)   \
  case MIX (typecode::type, typecode::type):   \
    return (mod_##suffix##suffix (interp, x, y))

#define DISPATCH_2(t1, t2, s1, s2)   \
  case MIX (typecode::t1, typecode::t2):   \
    return (mod_##s1##s2 (interp, x, y));   \
  case MIX (typecode::t2, typecode::t1):   \
    return (mod_##s2##s1 (interp, x, y))

      DISPATCH_1 (INT, i);
      DISPATCH_2 (INT, BIGINT, i, I);
      DISPATCH_2 (INT, FLOAT, i, f);
      DISPATCH_2 (INT, BIGFLOAT, i, F);

      DISPATCH_1 (BIGINT, I);
      DISPATCH_2 (BIGINT, FLOAT, I, f);
      DISPATCH_2 (BIGINT, BIGFLOAT, I, F);

      DISPATCH_1 (FLOAT, f);
      DISPATCH_2 (FLOAT, BIGFLOAT, f, F);

      DISPATCH_1 (BIGFLOAT, F);

      default:
        invalid_arg (interp, "mod");
    }

#undef DISPATCH_1
#undef DISPATCH_2
}

bool equal (interpreter *interp, object x, object y)
{
  if (x == y)
    // Identical objects compare equal iff they're not NaN or INF.
    return (x != FLT_QNAN && x != FLT_PINF && x != FLT_NINF);

#define eq_ii(interp, x, y)   false
#define eq_cc(interp, x, y)   false

  switch (MIX (itype (x), itype (y)))
    {
#define DISPATCH_1(type, suffix)   \
  case MIX (typecode::type, typecode::type):   \
    return (eq_##suffix##suffix (interp, x, y))

#define DISPATCH_2(t1, t2, s1, s2)   \
  case MIX (typecode::t1, typecode::t2):   \
    return (eq_##s1##s2 (interp, x, y));   \
  case MIX (typecode::t2, typecode::t1):   \
    return (eq_##s1##s2 (interp, y, x))

      DISPATCH_1 (INT, i);
      DISPATCH_2 (INT, FLOAT, i, f);

      DISPATCH_1 (BIGINT, I);
      DISPATCH_2 (BIGINT, FLOAT, I, f);
      DISPATCH_2 (BIGINT, BIGFLOAT, I, F);

      DISPATCH_1 (FLOAT, f);

      DISPATCH_1 (BIGFLOAT, F);

      DISPATCH_1 (BVECTOR, b);
      DISPATCH_2 (BVECTOR, STR, b, s);

      DISPATCH_1 (STR, s);

      DISPATCH_1 (ARRAY, a);

      DISPATCH_1 (CONS, L);

      DISPATCH_1 (CHAR, c);

      DISPATCH_1 (FCT, x);

      default:
        // XXX: Custom types.
        return (false);
    }

#undef eq_ii
#undef eq_cc
#undef DISPATCH_1
#undef DISPATCH_2
}

int xcmp (interpreter *interp, object x, object y)
{
  if (x == y)
    return (x != FLT_QNAN ? 0 : -1);

  switch (MIX (itype (x), itype (y)))
    {
#define DISPATCH_1(type, suffix)   \
  case MIX (typecode::type, typecode::type):   \
    return (cmp_##suffix##suffix (interp, x, y))

#define DISPATCH_2(t1, t2, s1, s2)   \
  case MIX (typecode::t1, typecode::t2):   \
    return (cmp_##s1##s2 (interp, x, y));   \
  case MIX (typecode::t2, typecode::t1):   \
    return (-cmp_##s1##s2 (interp, y, x))

      DISPATCH_1 (INT, i);
      DISPATCH_2 (INT, BIGINT, i, I);
      DISPATCH_2 (INT, FLOAT, i, f);
      DISPATCH_2 (INT, BIGFLOAT, i, F);

      DISPATCH_1 (BIGINT, I);
      DISPATCH_2 (BIGINT, FLOAT, I, f);
      DISPATCH_2 (BIGINT, BIGFLOAT, I, F);

      DISPATCH_1 (FLOAT, f);
      DISPATCH_2 (FLOAT, BIGFLOAT, f, F);

      DISPATCH_1 (BIGFLOAT, F);

      DISPATCH_1 (ARRAY, a);

      DISPATCH_1 (CONS, L);

      DISPATCH_1 (BVECTOR, b);
      DISPATCH_2 (BVECTOR, STR, b, s);

      DISPATCH_1 (STR, s);

      default:
        // XXX: Custom types.
        return (x < y ? -1 : 1);
    }

#undef DISPATCH_1
#undef DISPATCH_2
}

#define DEFBUILTIN(name)   \
  object name (interpreter *interp, object *argv, int argc)

// (car arg)
static DEFBUILTIN (car_fct)
{
  cons *cnp = as<cons> (*argv);
  if (!cnp)
    interp->raise ("type-error", "value is not a cons");

  kp_return (cnp->car);
}

// (cdr arg)
static DEFBUILTIN (cdr_fct)
{
  cons *cnp = as<cons> (*argv);
  if (!cnp)
    interp->raise ("type-error", "value is not a cons");

  kp_return (cnp->cdr);
}

// (cons arg1 arg2)
static DEFBUILTIN (cons_fct)
{
  return (cons::make (interp, argv[0], argv[1]));
}

// (list [...args])
DEFBUILTIN (list_fct)
{
  if (argc == 0)
    kp_return (NIL);

  object lst = alloc_cons (interp, argc);
  for (int i = 0; i < argc; ++i, lst = xcdr (lst))
    xcar(lst) = argv[i];

  kp_return (interp->alval);
}

// (list* arg1 [...args])
DEFBUILTIN (list_star)
{
  if (argc == 1)
    kp_return (*argv);

  object prev = 0, lst = alloc_cons (interp, argc - 1);

  for (int i = 0; i < argc - 1; ++i)
    {
      xcar(lst) = argv[i];
      prev = lst, lst = xcdr (lst);
    }

  xcdr(prev) = argv[--argc];
  kp_return (interp->alval);
}

// (+ [...args])
DEFBUILTIN (add_fct)
{
  if (argc == 0)
    kp_return (fixint (0));
  else if (argc == 1)
    {
      object tmp = *argv;
      switch (itype (tmp))
        {
          case typecode::INT:
          case typecode::FLOAT:
          case typecode::BIGINT:
          case typecode::BIGFLOAT:
            kp_return (tmp);
          default:
            invalid_arg (interp, "+");
        }
    }

  valref rv (interp, *argv);
  for (int i = 1; i < argc; ++i)
    *rv = add (interp, *rv, argv[i]);

  kp_return (*rv);
}

// (- arg1 [...args])
DEFBUILTIN (sub_fct)
{
  if (argc == 1)
    {
      object tmp = *argv;
      switch (itype (tmp))
        {
          case typecode::INT:
            return (neg_i (interp, tmp));
#ifdef KP_ARCH_WIDE
          case typecode::BIGINT:
          case typecode::FLOAT:
          case typecode::BIGFLOAT:
            kp_return (tmp ^ SIGN_BIT);
#else
          case typecode::BIGINT:
            return (neg_I (interp, tmp));
          case typecode::FLOAT:
            return (neg_f (interp, tmp));
          case typecode::BIGFLOAT:
            return (neg_F (interp, tmp));
#endif
          // XXX: Custom types.
          default:
            invalid_arg (interp, "-");
        }
    }

  valref rv (interp, *argv);
  for (int i = 1; i < argc; ++i)
    *rv = sub (interp, *rv, argv[i]);

  kp_return (*rv);
}

// (* [...args])
DEFBUILTIN (mul_fct)
{
  if (argc == 0)
    kp_return (fixint (1));

  valref rv (interp, *argv);
  for (int i = 1; i < argc; ++i)
    *rv = mul (interp, *rv, argv[i]);

  kp_return (*rv);
}

// (/ arg1 [...args])
DEFBUILTIN (div_fct)
{
  if (argc == 1)
    return (div (interp, fixint (1), *argv));

  valref rv (interp, *argv);
  for (int i = 1; i < argc; ++i)
    *rv = div (interp, *rv, argv[i]);

  kp_return (*rv);
}

// (lsh x shift)
DEFBUILTIN (lsh_fct)
{
  switch (itype (*argv))
    {
#define DISPATCH(type, suffix)   \
  case typecode::type:   \
    return (lsh_##suffix##i (interp, argv[0], argv[1]))

      DISPATCH (INT, i);
      DISPATCH (BIGINT, I);
      DISPATCH (FLOAT, f);
      DISPATCH (BIGFLOAT, F);

      default:
        if (bigint_p (argv[1]))
          interp->raise ("arith-error", "shift overflow");
        invalid_arg (interp, "lsh");
    }

#undef DISPATCH
}

// (rsh x shift)
DEFBUILTIN (rsh_fct)
{
  switch (itype (*argv))
    {
#define DISPATCH(type, suffix)   \
  case typecode::type:   \
    return (rsh_##suffix##i (interp, argv[0], argv[1]))

      DISPATCH (INT, i);
      DISPATCH (BIGINT, I);
      DISPATCH (FLOAT, f);
      DISPATCH (BIGFLOAT, F);

      default:
        if (bigint_p (argv[1]))
          interp->raise ("arith-error", "shift overflow");
        invalid_arg (interp, "rsh");
    }

#undef DISPATCH
}

// (< arg1 [...args])
DEFBUILTIN (lt_fct)
{
  for (int i = 0; i < argc - 1; ++i)
    if (!(xcmp (interp, argv[i], argv[i + 1]) < 0))
      kp_return (NIL);

  kp_return (symbol::t);
}

// (> arg1 [...args])
DEFBUILTIN (gt_fct)
{
  for (int i = 0; i < argc - 1; ++i)
    if (!(xcmp (interp, argv[i], argv[i + 1]) > 0))
      kp_return (NIL);

  kp_return (symbol::t);
}

// (<= arg1 [...args])
DEFBUILTIN (lte_fct)
{
  for (int i = 0; i < argc - 1; ++i)
    if (!(xcmp (interp, argv[i], argv[i + 1]) <= 0))
      kp_return (NIL);

  kp_return (symbol::t);
}

// (>= arg1 [...args])
DEFBUILTIN (gte_fct)
{
  for (int i = 0; i < argc - 1; ++i)
    if (!(xcmp (interp, argv[i], argv[i + 1]) >= 0))
      kp_return (NIL);

  kp_return (symbol::t);
}

// (!= arg1 [...args])
DEFBUILTIN (ne_fct)
{
  for (int i = 0; i < argc - 1; ++i)
    if (xcmp (interp, argv[i], argv[i + 1]) == 0)
      kp_return (NIL);

  kp_return (symbol::t);
}

// (nputcar val lst)
static DEFBUILTIN (nputcar_fct)
{
  cons *cnp = as<cons> (argv[1]);
  if (!cnp || cnp == as_cons (NIL))
    interp->raise ("type-error", "value is not a cons");

  kp_return (nputcar (interp, cnp->as_obj (), argv[0]));
}

// (nputcdr val lst)
static DEFBUILTIN (nputcdr_fct)
{
  cons *cnp = as<cons> (argv[1]);
  if (!cnp || cnp == as_cons (NIL))
    interp->raise ("type-error", "value is not a cons");

  kp_return (nputcdr (interp, cnp->as_obj (), argv[0]));
}

// (is x y)
static DEFBUILTIN (is_fct)
{
  kp_return (argv[0] == argv[1] ? symbol::t : NIL);
}

// (= x y [...args])
static DEFBUILTIN (eq_fct)
{
  for (int i = 0; i < argc - 1; ++i)
    if (!equal (interp, argv[i], argv[i + 1]))
      kp_return (NIL);

  kp_return (symbol::t);
}

// (array [...args])
DEFBUILTIN (array_fct)
{
  object ret = alloc_array (interp, argc, UNBOUND);
  copy_objs (&xaref(ret, 0), argv, argc);
  kp_return (ret);
}

// (tuple test_fn [...args])
DEFBUILTIN (tuple_fct)
{
  valref ret (interp, alloc_tuple (interp, *argv));

  for (int i = 1; i < argc; ++i)
    tuple_put (interp, *ret, argv[i], false);

  kp_return (*ret);
}

// (%putd symbol code definition)
DEFBUILTIN (p_putd)
{
  if (!fixint_p (argv[1]))
    interp->raise ("type-error", "second argument must be an integer");
  else if (!symbol_p (*argv))
    interp->raise ("type-error", "first argument must be a symbol");
  else if (as_symbol(*argv)->flagged_p (FLAGS_CONST))
    interp->raise ("const-error", "cannot assign to a constant");

  uint32_t eflags = 0;
  int type = as_int (argv[1]);

  switch (type)
    {
      case 0:  // function.
      case 5:  // regular symbol.
        break;

      case 1:   // constant.
        eflags |= FLAGS_CONST;
        break;

      case 2:   // special variable.
        eflags |= symbol::special_flag;
        break;

      case 3:   // macro.
        eflags |= symbol::ctv_flag;
        break;

      case 4:   // alias.
        eflags |= symbol::alias_flag;
        break;

      default:
        interp->raise ("arg-error", "invalid code "
          "(expected a value in range [0, 5])");
    }

  if (type == 0 || type == 3)
    {
      function *fp = as<function> (argv[2]);
      if (!fp)
        interp->raise ("type-error", "argument must be a function");

      if (nil_p (fp->name))
        // Mutate the argument and set the name.
        fp->name = *argv;
      else
        { // Copy the function with the new name.
          function *f2 = as_fct (alloc_fct (interp));
          fp->copy_into (f2);
          f2->name = *argv;
          argv[2] = f2->as_obj ();
        }
    }

  symval(*argv) = argv[2];
  if (eflags)
    {
      symbol *sp = as_symbol (*argv);
      sp->cas_flag (symbol::special_flag | symbol::ctv_flag |
        symbol::alias_flag, eflags);
      if ((eflags & symbol::special_flag) && !sp->tl_idx)
        sp->tl_idx = symbol::alloc_tl_idx (interp);
    }

  kp_return (argv[2]);
}

static inline object
strm_out (interpreter *interp)
{
  object obj = find_sym (interp, "*out*", 5);
  return (symbol_p (obj) ? symval (interp, obj) : out_stream);
}

static object
print_helper (interpreter *interp, object strm,
  object *argv, int argc, bool nl)
{
  stream *out = as<stream> (strm);
  stream_guard sg { interp, nullptr };
  lock_guard lg { interp, nullptr };

  if (out)
    ;
  else if (string *sp = as<string> (strm))
    out = sg.strmp = strstream (interp, sp->as_obj (),
                                STRM_WRITE | STRM_APP | STRM_NOLOCK);
  else
    interp->raise ("type-error", "output argument must be a string or stream");

  if (!singlethr_p () && !sg.strmp)
    lg.set (as_lock (out->ilock));

  io_info info;
  info.flags |= io_info::FLG_RAW;

  interp->retval = symbol::t;
  for (int i = 0; i < argc; ++i)
    if (xwrite (interp, out, argv[i], info) < 0)
      {
        interp->retval = NIL;
        break;
      }

  if (nl && !nil_p (interp->retval) && out->putb (interp, '\n') < 0)
    interp->retval = NIL;

  if (sg.strmp)
    sstream_get (interp, sg.strmp);

  return (interp->retval);
}

// (print-to stream arg1 [...args])
static DEFBUILTIN (print_to_fct)
{
  return (print_helper (interp, *argv, argv + 1, argc - 1, false));
}

// (say-to stream [...args])
static DEFBUILTIN (say_to_fct)
{
  return (print_helper (interp, *argv, argv + 1, argc - 1, true));
}

// (print arg1 [...args])
static DEFBUILTIN (print_fct)
{
  return (print_helper (interp, strm_out (interp), argv, argc, false));
}

// (say [...args])
static DEFBUILTIN (say_fct)
{
  return (print_helper (interp, strm_out (interp), argv, argc, true));
}

// (copy obj [deep])
static DEFBUILTIN (copy_fct)
{
  return (copy (interp, *argv, argc == 2 && !nil_p (argv[1])));
}

// (reverse obj)
DEFBUILTIN (reverse_fct)
{
  switch (itype (*argv))
    {
#define DISPATCH(type, suffix)   \
  case typecode::type:   \
    return (reverse_##suffix (interp, *argv))

      DISPATCH (ARRAY, a);
      DISPATCH (BVECTOR, b);
      DISPATCH (STR, s);
      DISPATCH (CONS, L);
      default:
        invalid_arg (interp, "reverse");
#undef DISPATCH
    }
}

// (nreverse obj)
DEFBUILTIN (nreverse_fct)
{
  switch (itype (*argv))
    {
#define DISPATCH(type, suffix)   \
  case typecode::type:   \
    return (nreverse_##suffix (interp, *argv))

      DISPATCH (ARRAY, a);
      DISPATCH (BVECTOR, b);
      DISPATCH (CONS, L);
      default:
        invalid_arg (interp, "nreverse");
#undef DISPATCH
    }
}

// (nput sequence key value)
DEFBUILTIN (nput_fct)
{
  switch (itype (*argv))
    {
#define DISPATCH(type, suffix)   \
  case typecode::type:   \
    kp_return (nput_##suffix (interp, argv[0], argv[1], argv[2]))

      DISPATCH (ARRAY, a);
      DISPATCH (BVECTOR, b);
      DISPATCH (CONS, L);
      DISPATCH (TABLE, u);
      DISPATCH (TUPLE, o);
      DISPATCH (PKG, P);
      DISPATCH (INSTANCE, w);
      default:
        invalid_arg (interp, "nput");

#undef DISPATCH
    }

  kp_return (UNBOUND);
}

// (disasm function [stream])
static DEFBUILTIN (disasm_fct)
{
  object out;
  bool allocated = false;

  if (argc < 2)
    {
      out = strm_out (interp);
      if (str_p (out))
        {
          out = strstream(interp, out,
            STRM_WRITE | STRM_APP | STRM_NOLOCK)->as_obj ();
          allocated = true;
        }
    }
  else
    out = argv[1];

  disasm (interp, *argv, out);

  if (allocated)
    {
      stream *ostr = as_stream (out);
      sstream_get (interp, ostr);
      ostr->close (interp);
    }
  else
    interp->retval = symbol::t;

  return (interp->retval);
}

// (not obj)
static DEFBUILTIN (not_fct)
{
  kp_return (nil_p (*argv) ? *argv : symbol::t);
}

// (len obj)
static DEFBUILTIN (len_fct)
{
  kp_return (length (interp, *argv));
}

struct custom_comparator : public comparator
{
  object cb;

  custom_comparator (interpreter *ip, object obj) :
      comparator (ip), cb (obj)
    {
      this->interp->growstk (3);
    }

  bool operator() (object x, object y)
    {
      *this->interp->stkend++ = this->cb;
      *this->interp->stkend++ = x;
      *this->interp->stkend++ = y;
      return (call_n (this->interp, 2) != NIL);
    }
};

// (nsort seq [comparison])
DEFBUILTIN (nsort_fct)
{
  lazy<comparator> c1;
  lazy<custom_comparator> c2;
  comparator *cx;

  if (argc == 1)
    cx = new (c1.ptr ()) comparator (interp);
  else
    cx = new (c2.ptr ()) custom_comparator (interp, argv[1]);

  switch (itype (*argv))
    {
      case typecode::CONS:
        return (nsort_L (interp, *argv, *cx));
      case typecode::ARRAY:
        return (nsort_a (interp, *argv, *cx));
      case typecode::TUPLE:
        kp_return (*argv);
      default:
        invalid_arg (interp, "nsort");
    }
}

// (subseq seq arg-1 [arg-2])
DEFBUILTIN (subseq_fct)
{
  object i2 = argc == 3 ? argv[2] : UNBOUND;
  switch (itype (*argv))
    {
#define DISPATCH(type, suffix)   \
  case typecode::type:   \
    return (subseq_##suffix (interp, argv[0], argv[1], i2))

      DISPATCH (CONS, L);
      DISPATCH (ARRAY, a);
      DISPATCH (BVECTOR, b);
      DISPATCH (STR, s);
      default:
        invalid_arg (interp, "subseq");

#undef DISPATCH
    }
}

// (concat [...args])
DEFBUILTIN (concat_fct)
{
  if (argc == 0)
    kp_return (NIL);

  switch (itype (*argv))
    {
#define DISPATCH(type, suffix)   \
  case typecode::type:   \
    return (concat_##suffix (interp, argv, argc))

      DISPATCH (CONS, L);
      DISPATCH (ARRAY, a);
      DISPATCH (BVECTOR, b);
      DISPATCH (STR, s);
      default:
        invalid_arg (interp, "concat");

#undef DISPATCH
    }
}

// (nrevconc obj)
static DEFBUILTIN (nrevconc_fct)
{
  return (nrevconc (interp, *argv, argv[1]));
}

// (load path)
DEFBUILTIN (load_fct)
{
  object path = *argv;
  if (!str_p (path))
    interp->raise ("type-error", "path must be a string");

  stream_guard sg (interp, fstream_open (interp, str_cdata (path), "r"));
  if (!*sg)
    // XXX: Report why the file couldn't be opened.
    interp->raise ("load-error",
      KP_SPRINTF (interp, "could not open file '%Q'", path));

  reader rd (interp, sg.as_obj ());

  while (true)
    {
      object expr = rd.read_sexpr ();
      if (expr == EOS)
        break;

      eval (interp, expr);
    }

  kp_return (symbol::t);
}

// (macroexp-1 expr)
static DEFBUILTIN (macroexp_1_fct)
{
  kp_return (macroexp_1 (interp, *argv));
}

// (macroexp expr)
static DEFBUILTIN (macroexp_fct)
{
  kp_return (macroexp (interp, *argv));
}

// (coro-val coroutine)
static DEFBUILTIN (coro_val)
{
  auto cnp = as<coroutine> (*argv);
  if (!cnp)
    interp->raise ("type-error", "argument must be a coroutine");

  kp_return (cnp->value);
}

// (symname symbol)
static DEFBUILTIN (symname_fct)
{
  symbol *sym = as<symbol> (*argv);
  if (!sym)
    interp->raise ("type-error", "argument must be a symbol");

  kp_return (sym->name);
}

// (symval symbol [default-value])
static DEFBUILTIN (symval_fct)
{
  symbol *sym = as<symbol> (*argv);
  if (!sym)
    interp->raise ("type-error", "first argument must be a symbol");

  object ret = sym->value;
  if (ret != UNBOUND)
    kp_return (ret);
  else if (argc == 2)
    kp_return (argv[1]);
  else
    interp->raise ("unbound-error",
      KP_SPRINTF (interp, "symbol %Q has no value", sym->as_obj ()));
}

// (sympkg symbol)
static DEFBUILTIN (sympkg_fct)
{
  symbol *sym = as<symbol> (*argv);
  if (!sym)
    interp->raise ("type-error", "argument must be a symbol or nil");

  kp_return (sym->pkg);
}

// (%use name (:as alias) (:pull (:all symbols...)))
static DEFBUILTIN (p_use_fct)
{
  object a1 = argc < 2 ? NIL : argv[1];
  object a2 = argc < 3 ? NIL : argv[2];
  kp_return (pull_pkg (interp, *argv, a1, a2));
}

// (%gc)
static DEFBUILTIN (p_gc)
{
  gc (false);
  kp_return (NIL);
}

// (%iter sequence token [advance])
static DEFBUILTIN (p_iter)
{
  object token = argc < 2 ? UNBOUND : argv[1];
  bool adv = argc == 3 && !nil_p (argv[2]);

#define DISPATCH(type, suffix)   \
  case typecode::type:   \
    kp_return (iter_##suffix (interp, *argv, token, adv))

  switch (itype (*argv))
    {
      DISPATCH (ARRAY, a);
      DISPATCH (CONS, L);
      DISPATCH (BVECTOR, b);
      DISPATCH (STR, s);
      DISPATCH (TABLE, u);
      DISPATCH (TUPLE, o);
      default:
        // XXX: Custom types
        invalid_arg (interp, "%iter");
    }

#undef DISPATCH
}

// (macro-fct symbol)
static DEFBUILTIN (macro_fct)
{
  object sym = *argv;
  if (!symbol_p (sym))
    interp->raise ("type-error", "argument must be a symbol");
  else if (!as_symbol(sym)->flagged_p (symbol::ctv_flag))
    kp_return (NIL);

  sym = symval (sym);
  kp_return (fct_p (sym) ? sym : NIL);
}

// (nzap sequence key flags fn [...args])
DEFBUILTIN (nzap_fct)
{
  uint32_t flags = (fixint_p (argv[2]) ? as_int (argv[2]) : 0) |
    (singlethr_p () ? NZAP_NOMT : 0);

#define DISPATCH(type, suffix)   \
  case typecode::type:   \
    return (nzap_##suffix (interp, argv[0], argv[1], flags,   \
      argv[3], &argv[4], argc - 4))

  switch (itype (*argv))
    {
      DISPATCH (ARRAY, a);
      DISPATCH (CONS, L);
      DISPATCH (TABLE, u);
      DISPATCH (TUPLE, o);
      DISPATCH (PKG, P);
      default:
        invalid_arg (interp, "nzap");
    }

#undef DISPATCH
}

// (intern string [package])
static DEFBUILTIN (intern_fct)
{
  string *name = as<string> (*argv);
  if (!name)
    interp->raise ("type-error", "first argument must be a string");

  package *p = nullptr;
  if (argc == 1)
    ;
  else if (!(p = as<package> (argv[1])))
    interp->raise ("type-error", "second argument must be a package");

  kp_return (intern (interp, name, p));
}

// (fct-name function)
static DEFBUILTIN (fct_name_fct)
{
  object fn = *argv;
  if (!fct_p (fn))
    interp->raise ("type-error", "argument must be a function");

  kp_return (fct_name (fn));
}

// (type object [parents slot-definitions])
static DEFBUILTIN (type_fct)
{
  if (argc == 1)
    kp_return (type (argv[0]));
  else if (argc == 2)
    kp_return (type (interp, argv[0], argv[1], NIL));
  else
    kp_return (type (interp, argv[0], argv[1], argv[2]));
}

// (make type [...args])
DEFBUILTIN (make_fct)
{
  kp_return (alloc_inst (interp, *argv, argv + 1, argc - 1));
}

// (isa object type1 [...types])
static DEFBUILTIN (isa_fct)
{
  for (int i = 1; i < argc; ++i)
    {
      int rv = instanceof (*argv, argv[i]);
      if (rv < 0)
        interp->raise ("type-error", "argument must be a typespec");
      else if (rv)
        kp_return (symbol::t);
    }

  kp_return (NIL);
}

// (%symtst symbol code)
static DEFBUILTIN (p_symtst)
{
  int code;
  const symbol *sym = as<symbol> (*argv);

  if (!sym)
    interp->raise ("type-error", "first argument must be a symbol");
  else if (!as<int> (argv[1], code))
    interp->raise ("type-error", "second argument must be an integer");
  else if (code == 5)
    kp_return (sym->value != UNBOUND &&
      !sym->flagged_p (symbol::ctv_flag | symbol::alias_flag) ?
        symbol::t : NIL);

  const uint32_t flags[] =
    {
      FLAGS_CONST,
      symbol::specform_flag,
      symbol::special_flag,
      symbol::ctv_flag,
      symbol::alias_flag
    };

  if (code < 0 || code >= (int)KP_NELEM (flags))
    interp->raise ("arg-error", "invalid code");

  kp_return (sym->flagged_p (flags[code]) ? symbol::t : NIL);
}

// (last sequence)
static DEFBUILTIN (last_fct)
{
  object obj = *argv;

#define DISPATCH(type, suffix)   \
  case typecode::type:   \
    return (last_##suffix (interp, obj))

  switch (itype (obj))
    {
      DISPATCH (CONS, L);
      DISPATCH (ARRAY, a);
      DISPATCH (BVECTOR, b);
      DISPATCH (STR, s);
      default:
        invalid_arg (interp, "last");
    }

#undef DISPATCH
}

// (last-err [include-traceback])
static DEFBUILTIN (last_err_fct)
{
  if (argc == 1 && !nil_p (*argv) && !nil_p (interp->last_err.value))
    {
      object ret = alloc_cons (interp, 2);
      xcar(ret) = interp->last_err.value;
      xcar(xcdr (ret)) = interp->last_tb;
      kp_return (ret);
    }

  kp_return (interp->last_err.value);
}

static DEFBUILTIN (find_fct)
{
  object obj = argv[0], key = argv[1];
  object start = UNBOUND, end = UNBOUND, test = UNBOUND;

  kwargs_parse (interp, argv + 2, argc - 2, "start", &start,
                "end", &end, "test", &test);

#define DISPATCH(type, suffix)   \
  case typecode::type:   \
    return (find_##suffix (interp, obj, key, start, end, test))

  switch (itype (obj))
    {
      DISPATCH (CONS, L);
      DISPATCH (ARRAY, a);
#if 0
      DISPATCH (BVECTOR, b);
      DISPATCH (STR, s);
#endif
      default:
        invalid_arg (interp, "find");
    }

#undef DISPATCH
}

// Names for the builtins.
static const char BUILTIN_NAMES[] =
  "car\0"
  "cdr\0"
  "cons\0"
  "list\0"
  "list*\0"
  "+\0-\0*\0/\0"
  "<\0>\0<=\0>=\0!=\0"
  "lsh\0"
  "rsh\0"
  "nputcar\0"
  "nputcdr\0"
  "apply\0"
  "is\0=\0"
  "array\0"
  "table\0"
  "tuple\0"
  "%putd\0"
  "gensym\0"
  "print-to\0"
  "say-to\0"
  "print\0"
  "say\0"
  "copy\0"
  "reverse\0"
  "nreverse\0"
  "nput\0"
  "disasm\0"
  "not\0"
  "len\0"
  "%fmt-str\0"
  "nsort\0"
  "subseq\0"
  "concat\0"
  "nconcat\0"
  "nrevconc\0"
  "load\0"
  "macroexp-1\0"
  "macroexp\0"
  "coro-val\0"
  "coro-next\0"
  "symname\0"
  "symval\0"
  "sympkg\0"
  "%use\0"
  "%gc\0"
  "%iter\0"
  "exit\0"
  "macro-fct\0"
  "nzap\0"
  "intern\0"
  "fct-name\0"
  "type\0"
  "make\0"
  "isa\0"
  "%symtst\0"
  "last\0"
  "last-err\0"
  "%meth-ctl\0"
  "find\0"
;

// List of builtins.

struct builtin_entry
{
  native_function::fn_type fn;
  int8_t min_argc;
  int8_t max_argc;
};

static const builtin_entry BUILTINS[] =
{
  { car_fct, 1, 1 },
  { cdr_fct, 1, 1 },
  { cons_fct, 2, 2 },
  { list_fct, 0, -1 },
  { list_star, 1, -1 },
  { add_fct, 0, -1 },
  { sub_fct, 1, -1 },
  { mul_fct, 0, -1 },
  { div_fct, 0, -1 },
  { lt_fct, 1, -1 },
  { gt_fct, 1, -1 },
  { lte_fct, 1, -1 },
  { gte_fct, 1, -1 },
  { ne_fct, 1, -1 },
  { lsh_fct, 2, 2 },
  { rsh_fct, 2, 2 },
  { nputcar_fct, 2, 2 },
  { nputcdr_fct, 2, 2 },
  { apply_fct, 2, -1 },
  { is_fct, 2, 2 },
  { eq_fct, 2, -1 },
  { array_fct, 0, -1 },
  { table_fct, 2, -1 },
  { tuple_fct, 1, -1 },
  { p_putd, 3, 3 },
  { gensym, 0, 0 },
  { print_to_fct, 2, -1 },
  { say_to_fct, 1, -1 },
  { print_fct, 1, -1 },
  { say_fct, 0, -1 },
  { copy_fct, 1, 2 },
  { reverse_fct, 1, 1 },
  { nreverse_fct, 1, 1 },
  { nput_fct, 3, 3 },
  { disasm_fct, 1, 2 },
  { not_fct, 1, 1 },
  { len_fct, 1, 1 },
  { p_fmt_str, 1, -1 },
  { nsort_fct, 1, 2 },
  { subseq_fct, 2, 3 },
  { concat_fct, 0, -1 },
  { nconcat, 0, -1 },
  { nrevconc_fct, 2, 2 },
  { load_fct, 1, 1 },
  { macroexp_1_fct, 1, 1 },
  { macroexp_fct, 1, 1 },
  { coro_val, 1, 1 },
  { coro_next, 1, 2 },
  { symname_fct, 1, 1 },
  { symval_fct, 1, 2 },
  { sympkg_fct, 1, 1 },
  { p_use_fct, 1, 3 },
  { p_gc, 0, -1 },
  { p_iter, 1, 3 },
  { exit_fct, 0, 1 },
  { macro_fct, 1, 1 },
  { nzap_fct, 4, -1 },
  { intern_fct, 1, 2 },
  { fct_name_fct, 1, 1 },
  { type_fct, 1, 3 },
  { make_fct, 1, -1 },
  { isa_fct, 2, -1 },
  { p_symtst, 2, 2 },
  { last_fct, 1, 1 },
  { last_err_fct, 0, 1 },
  { p_meth_ctl, 1, -1 },
  { find_fct, 2, 6 },
};

static native_function global_builtins[KP_NELEM (BUILTINS)];
object symbol::fast_global_syms[KP_NELEM (BUILTINS) + symbol::N_SPECFORMS + 1];

indexer_t index_seq (object seq)
{
  switch (itype (seq))
    {
      case typecode::CONS:
        return (get_L);
      case typecode::ARRAY:
        return (get_a);
      case typecode::BVECTOR:
        return (get_b);
      case typecode::STR:
        return (get_s);
      case typecode::TABLE:
        return (get_u);
      case typecode::TUPLE:
        return (get_o);
      case typecode::PKG:
        return (get_P);
      case typecode::INSTANCE:
        return (get_w);
      default:
        return (nullptr);
    }
}

builtin_iter::builtin_iter () : curp (BUILTIN_NAMES)
{
}

void builtin_iter::adv ()
{
  this->curp += strlen (this->curp) + 1;
}

bool builtin_iter::valid () const
{
  return (*this->curp != 0);
}

int builtin_idx (interpreter *interp, const char *name)
{
  int ix = 0;
  for (builtin_iter it; it.valid (); it.adv (), ++ix)
    if (strcmp (it.name (), name) == 0)
      return (ix + symbol::N_SPECFORMS);

  return (-1);
}

object builtin_fct (interpreter *interp, const char *name)
{
  int ix = builtin_idx (interp, name) - symbol::N_SPECFORMS;
  return (ix < 0 ? UNBOUND : global_builtins[ix].as_obj ());
}

object builtin_fct (interpreter *interp, int ix)
{
  return (ix < 0 || ix >= (int)KP_NELEM (BUILTINS) ?
    UNBOUND : global_builtins[ix].as_obj ());
}

static int
do_init_builtins (interpreter *interp)
{
  int ret = init_op::call_deps (interp, &init_symbols);
  if (ret != init_op::result_ok)
    return (ret);

  int ix = 0;

  for (builtin_iter it; it.valid (); it.adv (), ++ix)
    {
      auto *outp = ensure_mask (&global_builtins[ix]);

      outp->vo_full = function_base::native_flag;
      outp->vo_type = typecode::FCT;
      outp->fct = BUILTINS[ix].fn;
      outp->min_argc = BUILTINS[ix].min_argc;
      outp->max_argc = BUILTINS[ix].max_argc;

      object sym = outp->name = INTERN_N (it.name ());
      symval(sym) = outp->as_obj ();
      symbol::fast_global_syms[ix + symbol::N_SPECFORMS] = sym;
    }

  // Mark the end of the builtin symbols.
  symbol::fast_global_syms[KP_NELEM (BUILTINS) + symbol::N_SPECFORMS] = UNBOUND;
  return (ret);
}

init_op init_builtins (do_init_builtins, "builtins");

#undef INTERN
#undef INTERN_N

KP_DECLS_END

